home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / programm.ing / gfa / gfaexprt.lzh / GFAXPERT.LIB / COLOR.LST < prev    next >
Encoding:
File List  |  1986-10-19  |  4.9 KB  |  179 lines
  1. ' *****************
  2. ' *** COLOR.LST ***
  3. ' *****************
  4. '
  5. DEFWRD "a-z"
  6. '
  7. > PROCEDURE new.low.colors
  8.   ' *** new palette (Low resolution)
  9.   ' *** please,please,please, restore original palette before exiting program
  10.   LOCAL n,r,g,b,col$
  11.   RESTORE low.new.col.data
  12.   FOR n=0 TO 15
  13.     READ col$
  14.     r=VAL(LEFT$(col$))
  15.     g=VAL(MID$(col$,2,1))
  16.     b=VAL(RIGHT$(col$))
  17.     VSETCOLOR n,r,g,b
  18.   NEXT n
  19.   '
  20.   ' *** rgb-values of new palette (switch to Overwrite-mode of editor)
  21.   low.new.col.data:
  22.   DATA 777,000,XXX,XXX,XXX,XXX,XXX,XXX,XXX,XXX,XXX,XXX,XXX,XXX,XXX,XXX
  23. RETURN
  24. ' **********
  25. '
  26. > PROCEDURE new.med.colors
  27.   ' *** new palette (Medium resolution)
  28.   ' *** please,please,please, restore original palette before exiting program
  29.   LOCAL n,r,g,b,col$
  30.   RESTORE med.new.col.data
  31.   FOR n=0 TO 3
  32.     READ col$
  33.     r=VAL(LEFT$(col$))
  34.     g=VAL(MID$(col$,2,1))
  35.     b=VAL(RIGHT$(col$))
  36.     VSETCOLOR n,r,g,b
  37.   NEXT n
  38.   '
  39.   ' *** rgb-values of new palette (switch to Overwrite-mode of editor)
  40.   med.new.col.data:
  41.   DATA 777,000,XXX,XXX
  42. RETURN
  43. ' **********
  44. '
  45. > PROCEDURE save.palette
  46.   ' *** save current palette in integer-array
  47.   ' *** global :   OLD.PALETTE%()
  48.   LOCAL i
  49.   ERASE old.palette%()
  50.   DIM old.palette%(15)
  51.   FOR i=0 TO 15
  52.     old.palette%(i)=XBIOS(7,i,-1)
  53.   NEXT i
  54. RETURN
  55. ' ***
  56. > PROCEDURE restore.palette
  57.   ' *** restore original palette
  58.   LOCAL i
  59.   FOR i=0 TO 15
  60.     VOID XBIOS(7,i,old.palette%(i))
  61.   NEXT i
  62. RETURN
  63. ' **********
  64. '
  65. > PROCEDURE make.palette.string(VAR pal$)
  66.   ' *** save current palette in (Degas-compatible) string
  67.   LOCAL n
  68.   pal$=""
  69.   FOR n=0 TO 15
  70.     pal$=pal$+MKI$(XBIOS(7,n,-1))
  71.   NEXT n
  72. RETURN
  73. ' **********
  74. '
  75. > PROCEDURE change.palette(pal.string$)
  76.   ' *** change palette with (Degas-compatible) string
  77.   VOID XBIOS(6,L:VARPTR(pal.string$))
  78. RETURN
  79. ' **********
  80. '
  81. > PROCEDURE rgb.value(index,VAR rgb$)
  82.   ' *** returns RGB-string of color-index
  83.   ' *** uses Standard Array color.index()
  84.   LOCAL col%
  85.   col%=XBIOS(7,color.index(index),-1)
  86.   rgb$=RIGHT$(HEX$(col%),3)
  87. RETURN
  88. ' **********
  89. '
  90. > PROCEDURE screen(txt.col$,back.col$)
  91.   ' *** change color of all PRINTed text and color of background (TOS-screen !)
  92.   ' *** use RGB-strings (e.g. "777" for white)
  93.   ' *** uses Standard Array Color.index
  94.   ' *** saves old colors in global variables
  95.   ' *** global :  OLD.TEXT.COL$  OLD.BACK.COL$
  96.   old.text.col$=RIGHT$(HEX$(XBIOS(7,color.index(1),-1)),3)
  97.   old.back.col$=RIGHT$(HEX$(XBIOS(7,color.index(0),-1)),3)
  98.   VSETCOLOR 1,VAL(LEFT$(txt.col$)),VAL(MID$(txt.col$,2,1)),VAL(RIGHT$(txt.col$))
  99.   VSETCOLOR 0,VAL(LEFT$(back.col$)),VAL(MID$(back.col$,2,1)),VAL(RIGHT$(back.col$))
  100. RETURN
  101. ' **********
  102. '
  103. > PROCEDURE palette.box(x,y,h,w)
  104.   ' *** show palette in rectangle (spectrum)
  105.   ' *** left upper corner of rectangle at x,y
  106.   ' *** rectangle-height h; width of one color-box w
  107.   ' *** uses Standard Array color.index() and Standard Global black
  108.   LOCAL arect.fill,fill.adr%,i,x1,x2
  109.   x2=x+16*w+2
  110.   COLOR black
  111.   BOX x,y,x2,y+h
  112.   arect.fill=-1
  113.   fill.adr%=V:arect.fill
  114.   IF low.res!
  115.     FOR i=0 TO 15
  116.       x1=ADD(SUCC(x),MUL(i,w))
  117.       ARECT x1,SUCC(y),ADD(x1,w),PRED(ADD(y,h)),color.index(i),0,fill.adr%,0
  118.     NEXT i
  119.   ELSE IF med.res!
  120.     FOR i=0 TO 3
  121.       x1=ADD(SUCC(x),MUL(i,w))
  122.       ARECT x1,SUCC(y),ADD(x1,w),PRED(ADD(y,h)),color.index(i),0,fill.adr%,0
  123.     NEXT i
  124.   ENDIF
  125. RETURN
  126. ' **********
  127. '
  128. > PROCEDURE dim.colors(reg1,reg2,val)
  129.   ' *** dim colors from VDI color-index reg1 to reg2 with val
  130.   ' *** for val=1 color 254 (rgb) will become 143
  131.   ' *** use this Procedure to darken the screen temporarily
  132.   ' *** Procedure can also be used instead of CLS :
  133.   ' ***          FOR i=0 TO 7
  134.   ' ***            @dim.colors(0,15,1)
  135.   ' ***            PAUSE 3
  136.   ' ***          NEXT i
  137.   ' *** uses Standard Array color.index() and Procedure Rgb.value
  138.   LOCAL i,r,g,b
  139.   FOR i=reg1 TO reg2
  140.     @rgb.value(i,rgb$)
  141.     r=MAX(PRED(VAL(LEFT$(rgb$))),0)
  142.     g=MAX(PRED(VAL(MID$(rgb$,2,1))),0)
  143.     b=MAX(PRED(VAL(RIGHT$(rgb$))),0)
  144.     VSETCOLOR i,r,g,b
  145.   NEXT i
  146. RETURN
  147. ' **********
  148. '
  149. > PROCEDURE color.cycle(reg1,reg2,time)
  150.   ' *** cycles colors from from VDI color-index reg1 to reg2
  151.   ' *** cycles every time*0.005 seconds with EVERY (time=200 : 1 second)
  152.   ' *** call again to stop the color-cycling : @color.cycle(0,0,0)
  153.   ' *** uses Standard Array color.index()
  154.   ' *** global :  COLOR.CYCLE!  COL.REG1  COL.REG2
  155.   '
  156.   IF NOT color.cycle!
  157.     col.reg1=reg1
  158.     col.reg2=reg2
  159.     color.cycle!=TRUE
  160.     EVERY time GOSUB cycle.once
  161.   ELSE
  162.     color.cycle!=FALSE
  163.     EVERY STOP
  164.   ENDIF
  165. RETURN
  166. ' ***
  167. > PROCEDURE cycle.once
  168.   LOCAL col1%,col2%
  169.   col1%=XBIOS(7,color.index(col.reg2),-1)
  170.   FOR reg=col.reg1 TO PRED(col.reg2)
  171.     col2%=XBIOS(7,color.index(reg),-1)
  172.     ~XBIOS(7,color.index(reg),col1%)
  173.     SWAP col1%,col2%
  174.   NEXT reg
  175.   ~XBIOS(7,color.index(col.reg2),col1%)
  176. RETURN
  177. ' **********
  178. '
  179.